home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Args < prev    next >
Encoding:
Text File  |  1995-11-11  |  6.1 KB  |  200 lines  |  [TEXT/YERK]
  1. \ args - non-class support for named input parms, local variables
  2. \  6/28/85  cbd Dispose> named parms works correctly
  3. \  7/03/85  cbd Clear parmList in Pfind if interpreting
  4. \  9/24/85  cbd Hooks for floating point named args
  5. \  9/16/86  cdn Fixed dispose> to work for MM blocks as well as heap objects
  6. \  9/05/95    rfl Added Mexit (note must add fkills and things for fp
  7. \ 11/10/95    rfl    moved exit to source CLASS. Exit now works with methods and kills fargs
  8.  
  9. 0 value  inParms    \ # named input parameters
  10. 0 value  locFlg        \ true=looking for local var tokens
  11. 0 value  fltMask    \ bit on for each float parm
  12. 6 constant maxParms
  13.  
  14. \ stub for floating point pick words - patched by float package
  15. : fstub  cr ?error 167 ;    \ Floating Point not installed
  16.  
  17. \ tables of pick and store cfas
  18. 6 'cfas  mp5 mp4 mp3 mp2 mp1 mp0
  19.  variable mpicks , , , , ,
  20. 6 'cfas  ms5 ms4 ms3 ms2 ms1 ms0
  21.  variable mputs  , , , , ,
  22. 6 'cfas  fstub fstub fstub fstub fstub fstub    \ cbd  9/85  float support
  23.  variable fpicks , , , , ,
  24.  
  25. \ ( ind addr -- elem )  fetch an element from mpicks, mputs
  26. : @mp  swap 4* + @  ;
  27.  
  28. \ define an mcfa structure for 8-byte lists. This will hold
  29. \ the symbol table of input parm names during compilation of a word.
  30.  
  31. 3 Codefields  2 Prefix init8  1 prefix  ++8
  32.  
  33. \ 2cfa clears the list
  34.     ' init8 Do.. 0 swap w! ..End
  35.  
  36. \ ( dElem -- )  1cfa adds double element to list
  37.     ' ++8    Do.. >R R w@ R 2+ w@ >= ?error 110
  38.         R w@  1 R w+!    \ get current ind, incr by 1
  39.         8 * 4+ R> +  2!  ..End    \ calc addr of element and store
  40.  
  41. \ ( dElem -- ind t OR f )  Search for element in list
  42.             Do.. Pushm  0 rot rot copyM W@ 0    \ For current size, DO
  43.         DO I 8 * 4+ Copym + 2@ 2over D=    \ compare to this element
  44.             IF  2drop drop I 1 1 1 Leave THEN
  45.         LOOP  2drop Dropm ..End    \ could have used named parms here!!
  46.  
  47. \ define the builder for  8-byte lists
  48. : List8  Build  0 w,  dup w,    \ current size, max size
  49.     8 * reserve ..End
  50.  
  51. maxParms  list8 ParmList
  52.  
  53. \ Pad for WORD format string    Len|xxxxxxxxxx
  54. \ ( addr n -- )  Pad a string with blanks to n chars
  55. : PadBL
  56.     swap >R dup R c@ - dup 0>
  57.     IF  R c@ R + 1+ swap blanks
  58.     ELSE drop THEN R> c! ;    \ Update length byte
  59.  
  60. \ ( addr -- )  Copy the string at addr to Pad+1
  61. : ToPad  dup c@  Pad 1+ swap 1+ cmove  ;
  62.  
  63. \ ( -- char )  Get the first chart of the word at Here
  64. : firstChr    Here 1+ c@  ;
  65.  
  66. Forward LocalFloat
  67.  
  68. \ Begin a stack descriptor, reading parameters until }
  69. \ format:  : wordName { in1 in2 in3 \ loc1 loc2 loc3 -- out1 out2}
  70. \ ( -- )
  71. : {    ?Comp init8 ParmList 0 put fltMask
  72.     0 put inparms    0 put locFlg    \ ADDPARMS
  73.     BEGIN   BL word    \ Add parms or vars to parmlist
  74.         firstChr ascii - <>    \ look for --
  75.     WHILE   firstChr ascii \ =
  76.         IF  true put locFlg
  77.         ELSE   firstChr ascii } =
  78.             ?error 111
  79.             locFlg 0=    \ ADDPNAME - Add parm name at Here to list
  80.             IF inParms  1+ put inparms THEN    \ bump # input parms
  81.             firstChr ascii % =            \ float parm?
  82.             IF  1 ' Parmlist 8+ w@ <<  fltMask or put fltMask  THEN
  83.             Here ToPad   Pad 1+    8 PadBL
  84.             Pad 2+  2@  ++8 ParmList
  85.         THEN
  86.     REPEAT
  87.     ' Parmlist 8+ w@ -dup    \ get current size
  88.     IF  inParms - 4 << inParms or c, fltMask c,
  89.         CState   0= IF  'code  colP here 6 - ! THEN
  90.     THEN
  91.     BEGIN  BL word  firstChr 0= ?error 112
  92.         firstChr ascii } =    \ eat characters until }
  93.     UNTIL
  94.     fltMask inparms >> IF Compile LocalFloat THEN
  95. ; Immediate
  96.  
  97. \ ( addr -- ind t OR f )  Look up string in ParmList
  98. : (PFind)   ToPad  Pad 1+ 8 PadBl
  99.     Pad 2+  2@  ParmList  dup    \ look for this element
  100.     IF   pad 2+ c@ ascii % =
  101.         IF  swap 6 + swap THEN
  102.     THEN ;    \  cbd 9/85 float arg
  103.  
  104. \ -Find will call Pfind to attempt to find a name first
  105. \ ( -- f  OR  mpickPfa 0  t )
  106. : Pfind
  107.     State 0=
  108.     IF init8 parmList 0    \ cbd 7/03/85
  109.     ELSE  Here (Pfind)
  110.         IF  dup 6 <
  111.             IF  MPicks @mp  4+  0 1
  112.             ELSE 6 - fpicks @mp  4+ 0 1
  113.             THEN
  114.         ELSE  0 THEN
  115.     THEN ;
  116.  
  117. \ return the type of a token for prefix. An index of 0-5
  118. \ indicates a named parm, and a Forth word returns its cfa.
  119. \ ( -- cfa type )
  120. : prfToken  @word (pfind)
  121.     IF dup
  122.     ELSE  here latest (find) 0= ?error 113
  123.         drop cfa dup @
  124.     THEN  ;
  125.  
  126. 'code vmodel constant vectCode
  127. 'code keyvec constant svcode
  128. 'code in     constant valCode
  129. 0 value modCode
  130. 0 value fvalCode        \ float package must patch
  131.  
  132. 'c fstub value farg!    \ float  cbd  9/85
  133. 'c fstub value farg++    \ float  cbd  9/85
  134. 'c fstub value fKill
  135.  
  136. \ compile a cfa if in compile state, else exec it.
  137. : ,exec  state IF , ELSE execute THEN ;
  138.  
  139. \ the following prefix compilers detect whether their subject is
  140. \ a Value, Vect  or named parm, which allows them to operate
  141. \ on all types of variables.
  142. \ ( val -- )  Store stack value in named parm location
  143. : ->   prfToken
  144.     CASE
  145.         0 5        RANGEOF ?comp Mputs @mp , ENDOF
  146.         6 11       RANGEOF ?comp farg! , 6 - 4* 8+ w,  ENDOF    \ float arg
  147.         vectCode   OF  8+  ,exec ENDOF    \ compile 2cfa for store
  148.         svCode     OF  8+  ,exec ENDOF
  149.         valCode    OF  8+  ,exec ENDOF
  150.         fvalCode   OF  8+  ,exec ENDOF    \ cbd 9/85
  151.         ?error 114
  152.     ENDCASE  ;  Immediate
  153.  
  154. \ the following build a named parm ref by compiling the cfa of the
  155. \ runtime word followed by a word containing the offset of the
  156. \ named parm from the top of the mStack
  157.  
  158. \ ( val -- )  increment a named parm
  159. : ++>   prfToken
  160.     CASE
  161.         0 5        RANGEOF  Compile (++>)  4* 8+ w,     ENDOF
  162.         6 11       RANGEOF ?comp farg++ , 6 - 4* 8+ w,  ENDOF    \ float arg
  163.         valCode    OF  4+ ,exec ENDOF
  164.         fvalCode   OF  4+ ,exec ENDOF    \ cbd  9/85  float arg
  165.         ?error 114
  166.     ENDCASE  ;  Immediate
  167.  
  168. \ ( -- )  execute a procedural argument or variable
  169. : Exec>  prfToken
  170.     CASE
  171.         0 5        RANGEOF Compile  (ex>)  4* 8+ w,  ENDOF
  172.         vectCode   OF  ,exec  ENDOF    \ compile 0cfa for execute
  173.         svCode     OF  ,exec  ENDOF
  174.         valCode    OF  ,exec  'c execute ,exec  ENDOF
  175.         ?error 114
  176.     ENDCASE  ;  Immediate
  177.  
  178. Forward ?isObj    \ defined in Class
  179.  
  180. \ ( addr -- )  release block and 0 its vector
  181. : Dispose  dup @ -dup
  182.     IF    ?isObj IF cfa THEN    \ is a heap object
  183.         killPtr
  184.     THEN 0 swap ! ;
  185.  
  186. \ dispose> operation for value & method stack referenced data
  187. : (disp)  R @  R> 4+ >R  dispose ;
  188. : (mdisp) R w@ R> 2+ >R  2+ 4* mp@ + dispose ;
  189.  
  190. : Dispose>   prfToken
  191.     CASE
  192.         0 5      RANGEOF  ?comp Compile (mdisp) w,        ENDOF
  193.         valCode  OF   Compile (disp)  dup @ 2- W@ + ,    ENDOF
  194.         modCode  OF   8+ ,exec   ENDOF    \ module
  195.         ?error 114
  196.     ENDCASE  ; Immediate
  197.  
  198.  
  199. <" Class
  200.